VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "HttpBody"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private Body_p As Variant
Private Boundary_p As String
Public Files_p As Variant
Public extDic As Variant

'**********************************************
'* 名称：boundary
'* 类型：property
'* 描述：[Public]
'* 返回：无返回
'* 原型：public property get boundary() as string
'**********************************************


Public Property Get Boundary() As String
    Boundary = Boundary_p
End Property

'**********************************************
'* 名称：boundary
'* 类型：property
'* 描述：[Public]
'* 参数：val    (类型：string)
'* 返回：无返回
'* 原型：public property let boundary(val as string)
'**********************************************


Public Property Let Boundary(val As String)
    Boundary_p = val
End Property

'**********************************************
'* 名称：class_initialize
'* 类型：sub
'* 描述：[Private]
'* 返回：无返回
'* 原型：private sub class_initialize()
'**********************************************


Private Sub Class_Initialize()
    Set Body_p = CreateObject("Scripting.Dictionary")
    Set Files_p = CreateObject("Scripting.Dictionary")
    Set extDic = CreateObject("Scripting.Dictionary")
    Boundary = "----WebKitFormBoundarys1iVXNONaGEDO" & Int(((99999 - 10000) * Rnd() + 10000))
    
    extDic("ai") = "application/postscript"
    extDic("eps") = "application/postscript"
    extDic("exe") = "application/octet-stream"
    extDic("doc") = "application/vnd.ms-word"
    extDic("xls") = "application/vnd.ms-excel"
    extDic("ppt") = "application/vnd.ms-powerpoint"
    extDic("pps") = "application/vnd.ms-powerpoint"
    extDic("pdf") = "application/pdf"
    extDic("xml") = "application/xml"
    extDic("odt") = "application/vnd.oasis.opendocument.text"
    extDic("swf") = "application/x-shockwave-flash"
    '压缩文件类型的 "
    extDic("gz") = "application/x-gzip"
    extDic("tgz") = "application/x-gzip"
    extDic("bz") = "application/x-bzip2"
    extDic("bz2") = "application/x-bzip2"
    extDic("tbz") = "application/x-bzip2"
    extDic("zip") = "application/zip"
    extDic("rar") = "application/x-rar"
    extDic("tar") = "application/x-tar"
    extDic("7z") = "application/x-7z-compressed"
    '文字类型 "
    extDic("txt") = "text/plain"

   extDic("php") = "text/x-php"
    extDic("html") = "text/html"
    extDic("htm") = "text/html"
    extDic("js") = "text/javascript"
    extDic("css") = "text/css"
    extDic("rtf") = "text/rtf"
    extDic("rtfd") = "text/rtfd"
    extDic("py") = "text/x-python"
    extDic("java") = "text/x-java-source"
    extDic("rb") = "text/x-ruby"
    extDic("sh") = "text/x-shellscript"
    extDic("pl") = "text/x-perl"
    extDic("sql") = "text/x-sql"
    '图片类型的 "
    extDic("bmp") = "image/x-ms-bmp"
    extDic("jpg") = "image/jpeg"
    extDic("jpeg") = "image/jpeg"
    extDic("gif") = "image/gif"
    extDic("png") = "image/png"
    extDic("tif") = "image/tiff"
    extDic("tiff") = "image/tiff"
    extDic("tga") = "image/x-targa"
    extDic("psd") = "image/vnd.adobe.photoshop"
    '音频文件类型的 "
    extDic("mp3") = "audio/mpeg"
    extDic("mid") = "audio/midi"
    extDic("ogg") = "audio/ogg"
    extDic("mp4a") = "audio/mp4"
    extDic("wav") = "audio/wav"
    extDic("wma") = "audio/x-ms-wma"
    
    '视频文件类型的 "
    extDic("avi") = "video/x-msvideo"
    extDic("dv") = "video/x-dv"
    extDic("mp4") = "video/mp4"
    extDic("mpeg") = "video/mpeg"
    extDic("mpg") = "video/mpeg"
    extDic("mov") = "video/quicktime"
    extDic("wm") = "video/x-ms-wmv"
    extDic("flv") = "video/x-flv"
    extDic("mkv") = "video/x-matroska"
End Sub

'Value 只能为Byte数组或者 字符串
Public Sub Add(Name As String, Value As Variant)
    Body_p(Name) = Value
End Sub

'**********************************************
'* 名称：addfile
'* 类型：sub
'* 描述：[Public]
'* 参数：name   (类型：string)
'* 参数：filepath   (类型：string)
'* 返回：无返回
'* 原型：public sub addfile(name as string, filepath as string)
'**********************************************


'Value 只能为Byte数组或者 字符串
Public Sub AddFile(Name As String, FilePath As String)
    
    Dim fbuf() As Byte
    Dim FileName As String
    Dim fn
    FileName = Mid(FilePath, InStrRev(FilePath, "\") + 1)
    
    '------------------打开Adodb.stream 流读取二进制文件------------------
    fn = FreeFile()
    ReDim fbuf(FileLen(FilePath) - 1)
    Open FilePath For Binary As #fn
    Get #fn, , fbuf
    Close #fn
    
    Body_p(Name) = FileName
    Files_p(Name) = fbuf
End Sub

'**********************************************
'* 名称：remove
'* 类型：sub
'* 描述：[Public]
'* 参数：name   (类型：string)
'* 返回：无返回
'* 原型：public sub remove(name as string)
'**********************************************


Public Sub Remove(Name As String)
    If Body_p.Exists(Name) Then
        If Files_p.Exists(Body_p(Name)) Then
            Files_p.Remove Body_p(Name)
        End If
        Body_p.Remove Name
    End If
    
End Sub

Public Sub Clear()
    Body_p.Clear
end Sub

'**********************************************
'* 名称：requestbody
'* 类型：property
'* 描述：[Public]
'* 返回：无返回
'* 原型：public property get requestbody() as byte()
'**********************************************


Public Property Get RequestBody() As Byte()
    'Dim rs() As Byte
    Dim isFirst
    isFirst = True
    Dim key As Variant
    For Each key In Body_p
        Dim rsResult() As Byte
        Dim tempHeader() As Byte
        Dim tempData() As Byte
        Dim tempTail() As Byte
        Dim extName As String
        If Files_p.Exists(key) Then '本分段是文件
            extName = Mid(Body_p(key), InStrRev(Body_p(key), ".") + 1)
            Dim headerStr As String
            headerStr = IIf(isFirst, "", vbCrLf) & "--" & Boundary & vbCrLf _
                & "Content-Disposition:form-data; name=""" & key & """; filename=""" & Body_p(key) & """" & vbCrLf
            headerStr = headerStr & "Content-Type: " & IIf(extDic.Exists(extName), extDic(extName), "application/octet-stream") & vbCrLf & vbCrLf
            tempHeader = ToBytes(headerStr)
            
        Else '普通数据
            tempHeader = ToBytes(IIf(isFirst, "", vbCrLf) & "--" & Boundary & vbCrLf _
                & "Content-Disposition:form-data; name=""" & key & """" & vbCrLf & vbCrLf)
        End If
        isFirst = False
        
        
        If Files_p.Exists(key) And IsArray(Files_p(key)) Then
            Dim dataByte() As Byte
            dataByte = Files_p(key)
            tempData = dataByte
            
        Else
            tempData = ToBytes(Body_p(key))
        End If
        ArrayAdd rsResult, MergeArray(tempHeader, tempData)
    Next
    tempTail = ToBytes(vbCrLf & "--" & Boundary & "--" & vbCrLf)
    ArrayAdd rsResult, tempTail
    RequestBody = rsResult
End Property

Function MergeArray(ParamArray arrOthers() As Variant) As Variant
    Dim rs() As Byte
    Dim ilength As Long
    ilength = 1
    Dim pa As Variant
    For Each pa In arrOthers
        ArrayAdd rs, pa
    Next
    MergeArray = rs
End Function


Public Function ToBytes(ByVal str As String) As Variant
    'Dim rs() As Byte, rs_origin() As Byte
    'Dim i, newl
    'rs_origin = str
    'ToBytes = EncodeUTF8(str)
    'rs = str
    'ReDim rs(0)
    'For i = 0 To UBound(rs_origin)
    'If rs_origin(i) <> Hex(0) Then
    'newl = UBound(rs) + 1
    'ReDim Preserve rs(newl)
    'rs(newl - 1) = rs_origin(i)
    'End If
    'Next
    ToBytes = StrConv(str, vbFromUnicode)
End Function

Public Function Copy(ByRef arrA() As Byte)
    Dim rs()
    Dim i As Long
    ReDim rs(Length(arrA))
    For i = LBound(arrA) To UBound(arrA)
        rs(i - LBound(arrA)) = arrA(i)
    Next
    Copy = rs
End Function

'获得数组长度，若不是数组，返回-1
Public Function Length(arr As Variant) As Long
    If IsArray(arr) Then
        On Error GoTo noLength
        Dim l
        l = UBound(arr)
        GoTo hasLength
noLength:
        Length = 0
        GoTo ext
hasLength:
        Length = UBound(arr) - LBound(arr) + 1
    Else
        Length = -1
    End If
ext:
End Function

'将arrB追加到arrA后面。arrA 为可变数组,并且以0为首个索引号
Public Sub ArrayAdd(ByRef arrA As Variant, arrB As Variant)
    Dim l1 As Long, l2 As Long, i As Long
    l1 = Length(arrA)
    l2 = Length(arrB)
    If l2 > 0 Then
        ReDim Preserve arrA(0 To l1 + l2 - 1)
        For i = LBound(arrB) To UBound(arrB)
            arrA(l1 + i - LBound(arrB)) = arrB(i)
        Next
    End If
End Sub

Public Function ToStr(ByRef strData() As Byte) As String
    'Dim rs() As Byte, rs_origin() As Byte
    'Dim i, newl
    'rs_origin = str
    'ToBytes = EncodeUTF8(str)
    'rs = str
    'ReDim rs(0)
    'For i = 0 To UBound(rs_origin)
    'If rs_origin(i) <> Hex(0) Then
    'newl = UBound(rs) + 1
    'ReDim Preserve rs(newl)
    'rs(newl - 1) = rs_origin(i)
    'End If
    'Next
    ToStr = StrConv(strData, vbUnicode)
End Function




